home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / gjr / cmplrtst.lha / sort / hsort.scm < prev    next >
Encoding:
Text File  |  1990-03-27  |  1.7 KB  |  77 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (declare (usual-integrations))
  4.  
  5. (let-syntax ((define-integrable
  6.            (macro (params . body)
  7.          `(begin
  8.             (declare (integrate-operator ,(car params)))
  9.             (define ,(car params)
  10.               (named-lambda ,params
  11.             (declare (integrate ,@(cdr params)))
  12.             ,@body))))))
  13.  
  14. (define (sort obj pred)
  15.   (cond ((pair? obj)
  16.      (vector->list (sort! (list->vector obj) pred)))
  17.     ((vector? obj)
  18.      (sort! (vector-copy obj) pred))
  19.     ((null? obj)
  20.      '())
  21.     (else
  22.      (error "sort: argument should be a list or a vector"))))
  23.  
  24. (define (sort! vec pred)
  25.   (define-integrable (exchange! i j)
  26.     (let ((old (vector-ref vec i)))
  27.       (vector-set! vec i (vector-ref vec j))
  28.       (vector-set! vec j old)))
  29.  
  30.   (define (heapify-up n)
  31.     (let ((next (quotient (-1+ n) 2)))
  32.       (if (and (not (zero? n))
  33.            (not (pred (vector-ref vec n)
  34.               (vector-ref vec next))))
  35.       (begin
  36.         (exchange! n next)
  37.         (heapify-up next)))))
  38.         
  39.   (define (heapify-down n max)
  40.     (define-integrable (check m)
  41.       (if (pred (vector-ref vec n)
  42.         (vector-ref vec m))
  43.       (begin
  44.         (exchange! n m)
  45.         (heapify-down m max))))
  46.  
  47.     (let* ((p (+ n n 1))
  48.        (q (1+ p)))
  49.       (if (and (<= q max)
  50.            (not (pred (vector-ref vec q)
  51.               (vector-ref vec p))))
  52.       (check q)
  53.       (if (<= p max)
  54.           (check p)))))
  55.  
  56.   (if (not (vector? vec))
  57.       (error "sort!: argument must be a vector" vec))
  58.  
  59.   (let ((max (-1+ (vector-length vec))))
  60.  
  61.     (define (heapify-loop n)
  62.       (if (<= n max)
  63.       (begin
  64.         (heapify-up n)
  65.         (heapify-loop (1+ n)))))
  66.       
  67.     (define (sort-loop dest)
  68.       (if (> dest 0)
  69.       (begin
  70.         (exchange! dest 0)
  71.         (heapify-down 0 (-1+ dest))
  72.         (sort-loop (-1+ dest)))))
  73.  
  74.     (heapify-loop 0)
  75.     (sort-loop max)
  76.     vec))
  77. ) ;; End of let-syntax